;fonction de création des registres
;vm: nom de la vm sur laquelle faire l'opération
(defun Initialise-registre(vm)
  (progn
					;création des registres spéciaux
    (setf(get vm 'FP)0)
    (setf(get vm 'SP)0)
    (setf(get vm 'PC)0)

					;création des registres de données
    (setf(get vm 'R0)0)
    (setf(get vm 'R1)0)
    (setf(get vm 'R2)0)
    (setf(get vm 'R3)0)
    (setf(get vm 'R4)0)
    (setf(get vm 'R5)0)
    (setf(get vm 'R6)0)
    (setf(get vm 'R7)0)
    (setf(get vm 'R8)0)

					;création des drapeaux
    (setf(get vm 'DPG)0)
    (setf(get vm 'DPP)0)
    (setf(get vm 'DEQ)0)
    vm))

;fonction de création de la memoire
;vm: le nom de la machine virtuelle a creer
;taille: la taille de la memoire allouer a la vm
(defun creation-memoire (vm taille)
  (progn
    (setf(get vm 'CH)0)
    (setq table-globale (make-hash-table))
    (setq table-globale-avant (make-hash-table))
    (setf(get vm 'memory)(make-array taille :initial-element 0))
    (setf(get vm 'memory-max)(- taille 1))
    (setf(get vm 'CH)(- taille 1))))

;affiche le contenu de la memoire
(defun affiche-memoire(vm)
  (get vm 'memory))

;fonction d'acces en lecture aux registres
;vm: nom de la vm sur laquelle faire l'opération
;reg: nom du registre a lire
(defun get-register (vm reg)
  (get vm reg))

;fonction d'acces en ecriture aux registres
;vm: nom de la vm sur laquelle faire l'opération
;x: nouvelle valeur à affecter au registre
(defun set-register (vm reg x)
  (setf(get vm reg) x))

;mise à egalité des flag
(defun flag-eq(vm)
  (set-register vm 'dpp 0)
  (set-register vm 'deq 1)
  (set-register vm 'dpg 0))

;mise à plus petit des flag
(defun flag-pp(vm)
  (set-register vm 'dpp 1)
  (set-register vm 'deq 0)
  (set-register vm 'dpg 0))

;mise à plus grand des falg
(defun flag-pg(vm)
  (set-register vm 'dpp 0)
  (set-register vm 'deq 0)
  (set-register vm 'dpg 1))

;fonction d'acces en lecture à la memoire
;vm: nom de la vm sur laquelle faire l'opération
;n: position de l'information à lire dans la mémoire
(defun get-memory (vm n)
  (aref (get vm 'memory) n))

;fonction d'acces en ecriture à la memoire
;vm: nom de la vm sur laquelle faire l'opération
;n: position de l'information à modifier dans la mémoire
;x: nouvelle valeur à affecter au registre
(defun set-memory (vm n x)
  (setf(aref (get vm 'memory) n)x))

;fonction de verification de données, retourne vrai si le paramètre est un registre, faux sinon
;r: donnée à vérifier
(defun registre?(r)
  (or(eql 'fp r)(eql 'sp r)(eql 'pc r)(eql 'r0 r)(eql 'r1 r)(eql 'r2 r)(eql 'r3 r)(eql 'r4 r)(eql 'r5 r)(eql 'r6 r)(eql 'r7 r)(eql 'r8 r)(eql 'CH r)))

;fonction de copie de r0 dans r1
;vm: nom de la vm sur laquelle faire l'opération
;r0: donnée à copier, peut être soit un registre soit une valeur
;r1: registre de reception de copie
(defun move(vm r0 r1)
  (if(registre? r1)
      (if(registre? r0)
	  (set-register vm r1 (get-register vm r0))
	(set-register vm r1 r0))
    (print '"ERREUR: Le recepteur de la copie (MOVE) n'est pas un registre")))

;fonction d'addition dont le resultat se trouve dans r1
;vm: nom de la vm sur laquelle faire l'opération
;r0: premier paramètre d'addition, peut etre soit un registre soit une valeur
;r1: deuxième paramètre d'addition, recepteur de l'opération
(defun add(vm r0 r1)
  (if(registre? r1)
      (if(registre? r0)
	  (if(and(integerp(get-register vm r0))(integerp(get-register vm r0)))
	      (set-register vm r1 (+(get-register vm r0)(get-register vm r1)))
	    (print "ERREUR: Au moins un des composants de l'addition (ADD) n'est pas un nombre"))
	(if(and(integerp(get-register vm r1))(integerp r0))
	    (set-register vm r1 (+ r0 (get-register vm r1)))
	  (print "ERREUR: Au moins un des composants de l'addition (ADD) n'est pas un nombre")))
    (print '"ERREUR: Le recepteur de l'addition (ADD) n'est pas un registre")))

;fonction de soustraction dont le resultat se trouve dans r1
;vm: nom de la vm sur laquelle faire l'opération
;r0: premier paramètre de soustraction, peut etre soit un registre soit une valeur
;r1: deuxième paramètre de soustraction, recepteur de l'opération
(defun sub(vm r0 r1)
  (if(registre? r1)
      (if(integerp(get-register vm r1))
	  (progn
	    (set-register vm r1(* -1 (get-register vm r1)))
	    (add vm r0 r1))
	(print "ERREUR: Au moins un des composants de l'addition (SUB) n'est pas un nombre"))
    (print '"ERREUR: Le recepteur de la soustraction (SUB) n'est pas un registre")))

;enregistre le resultat de la multiplication de des deux registres dans le deuxieme
(defun mult(vm r0 r1)
  (if(registre? r1)
      (if(registre? r0)
	  (if(and(integerp(get-register vm r0))(integerp(get-register vm r0)))
	      (set-register vm r1 (*(get-register vm r0)(get-register vm r1)))
	    (print "ERREUR: Au moins un des composants de la multiplication (MULT) n'est pas un nombre"))
	(if(and(integerp(get-register vm r1))(integerp r0))
	    (set-register vm r1 (* r0 (get-register vm r1)))
	  (print "ERREUR: Au moins un des composants de la multiplication (MULT) n'est pas un nombre")))
    (print '"ERREUR: Le recepteur de la multiplication (MULT) n'est pas un registre")))

;enregistre le resultat de la division du premier registre par le deuxieme et l'enregistre dans le deuxieme
(defun div(vm r0 r1)
  (if(registre? r1)
      (if(registre? r0)
	  (if(and(integerp(get-register vm r0))(integerp(get-register vm r0)))
	      (if(eql(get-register vm r1)0)
		  (set-register vm r1 (/(get-register vm r0)(get-register vm r1)))
		(print "ERREUR: division par 0 impossible"))
	    (print "ERREUR: Au moins un des composants de la multiplication (MULT) n'est pas un nombre"))
	(if(and(integerp(get-register vm r1))(integerp r0))
	    (if(eql 0 r1)
		(set-register vm r1 (* r0 (get-register vm r1)))
	      (print "ERREUR: division par 0 impossible"))
	  (print "ERREUR: Au moins un des composants de la multiplication (MULT) n'est pas un nombre")))
    (print '"ERREUR: Le recepteur de la multiplication (MULT) n'est pas un registre")))
  

;fonction d'incrémentation
;vm: nom de la vm sur laquelle faire l'opération
;r0: registre à incrémenter
(defun incr(vm r0)
  (add vm 1 r0))

;fonction de décrémentation
;vm: nom de la vm sur laquelle faire l'opération
;r0: registre à décrémenter
(defun decr(vm r0)
  (add vm -1 r0))

(defun charge(vm r0 r1)
  (if(integerp r0)
      (if(and(>= r0 0))
	  (set-register vm r1(get-memory vm r0))
	(print "ERREUR: La valeur entrée pour acceder a la memoire doit etre supérieure à 0."))
    (print "ERREUR: La valeur entrée pour acceder a la memoire doit etre un entier")))

;fonction de chargement d'une donnée de la memoire à un registre
;vm: nom de la vm sur laquelle faire l'opération
;r0: rang de la memoire depuis laquelle charger
;r1: registre recepteur
(defun lload(vm r0 r1)
  (if(registre? r1)
      (if(atom r0)
	  (if(registre? r0)
	      (charge vm (get-register vm r0) r1)
	    (charge vm r0 r1))
	(if(registre? (car r0))
	    (if(integerp (cadr r0))
		(charge 'vm (+ (get-register vm (car r0))(cadr r0)) r1)
	      (error "l'element à additionné au registre dans load doit entre un entier."))
	  (error "Le premier element de la liste donné à load doit etre un registre.")))
    (print "ERREUR: Le recepteur de l'opération (LOAD) n'est pas un registre")))

(defun stock(vm r0 r1)
  (if(integerp r1)
	  (if(and(>= r1 0)(<= r1 (get vm 'CH)))
	      (set-memory vm r1 r0)
	    (print "ERREUR: La valeur entrée pour acceder a la memoire doit etre compris entre 0 et la valeur de sp"))
	(print "ERREUR: La valeur entrée pour acceder a la memoire doit etre un entier")))

;fonction de chargement d'une donnée à la memoire
;vm: nom de la vm sur laquelle faire l'opération
;r0: element a stocker
;r1: rang de la memoire dans laquelle stocker
(defun lstore(vm r0 r1)
  (if(registre? r0)
      (if(atom r1)
	  (if(registre? r1)
	      (stock vm (get-register vm r0)(get-register vm r1))
	    (stock vm (get-register vm r0) r1))
	(if(registre? (car r1))
	    (if(integerp (cadr r1))
		(stock vm (get-register vm r0) (+ (get-register 'vm (car r1))(cadr r1)))
	      (error "L'element à additionné au registre dans store doit etre un entier."))
	  (error "Le premier element de la liste donné à store doit etre un registre.")))
    (if(atom r1)
	(if(registre? r1)
	    (stock vm r0 (get-register vm r1))
	  (stock vm r0 r1))
      (if(registre? (car r1))
	  (if(integerp (cadr r1))
	      (stock vm r0 (+ (get-register 'vm (car r1))(cadr r1)))
	    (error "L'element à additionné au registre dans store doit etre un entier."))
	(error "Le premier element de la liste donné à store doit etre un registre.")))))

;fonction d'empilation de la mémoire
;vm: nom de la vm sur laquelle faire l'opération
;r0: le registre ou la valeur à empiler
(defun lpush(vm r0)
  (if(<(get-register vm 'sp)(get vm 'CH))
      (if(registre? r0)
	  (progn
	    (incr vm 'sp)
	    (set-memory vm (get-register vm 'sp)(get-register vm r0)))
	(progn
	  (incr vm 'sp)
	  (set-memory vm (get-register vm 'sp) r0)))
    (print "ERREUR: Depacement de pile(PUSH)")))

;fonction de dépilation de la mémoire
;vm: nom de la vm sur laquelle faire l'opération
;r0: le registre ou se trouvera la valeur dépiler
(defun lpop(vm r0)
  (if(>(get-register vm 'sp)0)
      (if(registre? r0)
	  (progn
	    (set-register vm r0(get-memory vm (get-register vm 'sp)))
	    (decr vm 'sp))
	(print "ERREUR: Le recepteur de l'opération (POP) n'est pas un registre"))
    (print "ERREUR: La pile est vide (POP)")))



;fonction de comparaison d'entier, r2 prend 0 si r0 et r1 sont égaux, 1 si r0<r1 et 2 si r0>r1
;vm: nom de la vm sur laquelle faire l'opération
;r0: premier registre ou valeur à comparer
;r1: deuxiéme registre ou valeur à comparer
;r2: recepteur de la comparaison
(defun comp(vm r0 r1)
  (if(registre? r0)
      (if (registre? r1)
	  (if(and(integerp(get-register vm r0))(integerp(get-register vm r1)))
	      (if(=(get-register vm r0)(get-register vm r1))
		  (flag-eq vm)
		(if(<(get-register vm r0)(get-register vm r1))
		    (flag-pp vm)
		  (flag-pg vm)))
	    (print "ERREUR: Au moins un des composants de la comparaison (COMP) n'est pas un entier"))
	(if(and(integerp(get-register vm r0))(integerp r1))
	    (if(=(get-register vm r0)r1)
		(flag-eq vm)
	      (if(<(get-register vm r0)r1)
		  (flag-pp vm)
		(flag-pg vm)))
	  (print "ERREUR: Au moins un des composants de la comparaison (COMP) n'est pas un entier")))
    (if(registre? r1)
	(if(and(integerp r0)(integerp(get-register vm r1)))
	    (if(= r0 (get-register vm r1))
		(flag-eq vm)
	      (if(< r0 (get-register vm r1))
		  (flag-pp vm)
		(flag-pg vm)))
	  (print "ERREUR: Au moins un des composants de la comparaison (COMP) n'est pas un entier"))
      (if(and(integerp r0)(integerp r1))
	  (if(= r0 r1)
	      (flag-eq vm)
	    (if(< r0 r1)
		(flag-pp vm)
	      (flag-pg vm)))
	(print "ERREUR: Au moins un des composants de la comparaison (COMP) n'est pas un entier")))))

;imprime en console la valeur contenue dans r0
(defun prin(vm r0)
  (if(registre? r0)
      (print (get-register vm r0))
    (print r0)))

;fonction de saut de ligne de code
;vm: nom de la vm sur laquelle faire l'opération
;r0: le registre ou la valeur vers laquelle le saut va etre effectuer
(defun jump(vm r0)
  (if(registre? r0)
      (if(integerp(get-register vm r0))
	  (set-register vm 'pc (get-register 'vm r0))
	(print "ERREUR: Le registre ne contient pas un entier (JUMP)"))
    (if(integerp r0)
	(set-register vm 'pc r0))))

;fonction de saut de ligne de code avec condition, effectué si le registre r0 est sur le drapeau de l'égalité
;vm: nom de la vm sur laquelle faire l'opération
;r0: le registre ou la valeur vers laquelle le saut va etre effectuer
(defun jeq(vm r0)
  (if(eql 1 (get-register vm 'deq))
      (jump vm r0)
    (decr vm 'pc)))

;fonction de saut de ligne de code avec condition, effectué si le registre r0 n'est pas sur le drapeau de l'égalité
;vm: nom de la vm sur laquelle faire l'opération
;r0: le registre ou la valeur vers laquelle le saut va etre effectuer
(defun jne(vm r0)
  (if(eql 0 (get-register vm 'deq))
      (jump vm r0)
    (decr vm 'pc)))

;fonction de saut de ligne de code avec condition, effectué si le registre r0 est sur le drapeau plus petit
;vm: nom de la vm sur laquelle faire l'opération
;r0: le registre ou la valeur vers laquelle le saut va etre effectuer
(defun jlo(vm r0)
  (if(eql 1 (get-register vm 'dpp))
      (jump vm r0)
    (decr vm 'pc)))

;fonction de saut de ligne de code avec condition, effectué si le registre r0 est sur le drapeau plus grand
;vm: nom de la vm sur laquelle faire l'opération
;r0: le registre ou la valeur vers laquelle le saut va etre effectuer
(defun jgr(vm r0)
  (if(eql 1 (get-register vm 'dpg))
      (jump vm r0)
    (decr vm 'pc)))

;fonction de saut de ligne de code avec condition, effectué si le registre r0 est sur le drapeau de l'égalité ou plus petit
;vm: nom de la vm sur laquelle faire l'opération
;r0: le registre ou la valeur vers laquelle le saut va etre effectuer
(defun jle(vm r0)
  (if(or(eql 1 (get-register vm 'deq))(eql 1 (get-register vm 'dpp)))
      (jump vm r0)
    (decr vm 'pc)))

;fonction de saut de ligne de code avec condition, effectué si le registre r0 est sur le drapeau de l'égalité ou plus grand
;vm: nom de la vm sur laquelle faire l'opération
;r0: le registre ou la valeur vers laquelle le saut va etre effectuer
(defun jge(vm r0)
  (if(or(eql 1 (get-register vm 'deq))(eql 1 (get-register vm 'dpg)))
      (jump vm r0)
    (decr vm 'pc)))

;fonction de saut a une fonction avec une notion de retour
(defun jsr(vm r0)
  (lpush vm (- (get-register vm 'pc) 1))
  (jump vm r0))

;fonction de retour a une fonction
(defun rtn(vm)
  (lpop vm 'r8)
  (if(eql(get-register vm 'r8)0)
      'HALT
    (jump vm 'r8)))

;fonction de lecture d'une ligne de commande d'assembleur
;vm: nom de la vm sur laquelle faire l'opération
;l: liste contenant la ligne de commande
(defun lecture-ligne(vm l)
  (progn
    (if(atom l)
      (decr vm 'pc)
    (cond
     ((eql(car l)'MOVE)(if(not(=(length l)3))
			   (print "ERREUR: MOVE necessite 2 arguments")
			 (progn
			   (move vm (cadr l)(caddr l))
			   (decr vm 'pc))))
     ((eql(car l)'ADD)(if(not(=(length l)3))
			  (print "ERREUR: ADD necessite 2 arguments")
			(progn
			  (add vm (cadr l)(caddr l))
			  (decr vm 'pc))))
     ((eql(car l)'SUB)(if(not(=(length l)3))
			  (print "ERREUR: SUB necessite 2 arguments")
			(progn
			  (sub vm (cadr l)(caddr l))
			  (decr vm 'pc))))
     ((eql(car l)'MULT)(if(not(=(length l)3))
			  (print "ERREUR: MULT necessite 2 arguments")
			(progn
			  (mult vm (cadr l)(caddr l))
			  (decr vm 'pc))))
     ((eql(car l)'DIV)(if(not(=(length l)3))
			  (print "ERREUR: DIV necessite 2 arguments")
			(progn
			  (div vm (cadr l)(caddr l))
			  (decr vm 'pc))))
     ((eql(car l)'INCR)(if(not(=(length l)2))
			   (print "ERREUR: INCR necessite 1 argument")
			 (progn
			   (incr vm (cadr l))
			   (decr vm 'pc))))
     ((eql(car l)'DECR)(if(not(=(length l)2))
			   (print "ERREUR: DECR necessite 1 argument")
			 (progn
			   (decr vm (cadr l))
			   (decr vm 'pc))))
     ((eql(car l)'STORE)(if(not(=(length l)3))
			   (print "ERREUR:STORE necessite 2 arguments")
			 (progn
			   (lstore vm (cadr l)(caddr l))
			   (decr vm 'pc))))
     ((eql(car l)'LOAD)(if(not(=(length l)3))
			   (print "ERREUR:LOAD necessite 2 arguments")
			 (progn
			   (lload vm (cadr l)(caddr l))
			   (decr vm 'pc))))
     ((eql(car l)'PUSH)(if(not(=(length l)2))
			   (print "ERREUR: PUSH necessite 1 argument")
			 (progn
			   (lpush vm (cadr l))
			   (decr vm 'pc))))
     ((eql(car l)'POP)(if(not(=(length l)2))
			   (print "ERREUR: POP necessite 1 argument")
			 (progn
			   (lpop vm (cadr l))
			   (decr vm 'pc))))
     ((eql(car l)'COMP)(if(not(=(length l)3))
			   (print "ERREUR: COMP necessite 2 arguments")
			 (progn
			   (comp vm (cadr l)(caddr l))
			   (decr vm 'pc))))
     ((eql(car l)'PRINT)(if(not(=(length l)2))
			    (print "ERREUR: PRINT necessite 1 argument")
			  (progn
			    (prin vm (cadr l))
			    (decr vm 'pc))))
     ((eql(car l)'JUMP)(if(not(=(length l)2))
			   (print "ERREUR: JUMP necessite 1 argument")
			 (jump vm (cadr l))))
     ((eql(car l)'JLO)(if(not(=(length l)2))
			   (print "ERREUR: JLO necessite 1 argument")
			 (jlo vm (cadr l))))
     ((eql(car l)'JEQ)(if(not(=(length l)2))
			   (print "ERREUR: JEQ necessite 1 argument")
			 (jeq vm (cadr l))))
     ((eql(car l)'JGR)(if(not(=(length l)2))
			   (print "ERREUR: JGR necessite 1 argument")
			 (jgr vm (cadr l))))
     ((eql(car l)'JLE)(if(not(=(length l)2))
			   (print "ERREUR: JLE necessite 1 argument")
			 (jle vm (cadr l))))
     ((eql(car l)'JGE)(if(not(=(length l)2))
			   (print "ERREUR: JGE necessite 1 argument")
			 (jge vm (cadr l))))
     ((eql(car l)'JNE)(if(not(=(length l)2))
			  (print "ERREUR: JNE necessite 1 argument")
			(jne vm (cadr l))))
     ((eql(car l)'JSR)(if(not(=(length l)2))
			  (print "ERREUR: JSR necessite 1 argument")
			(jsr vm (cadr l))))
     ((eql(car l)'RTN)(if(not(=(length l)1))
			  (print "ERREUR: RTN ne necessite pas d'argument")
			(rtn vm)))
     ((eql(car l)'HALT)(car l))
     (T (if(fboundp(car l))
	      (progn
		(setf a (apply (car l) (get-register-list vm (cdr l))))
		(if(eql a T)
		    (set-register 'vm 'r0 1)
		  (if(eql a NIL)
		      (set-register 'vm 'r0 0)
		    (set-register 'vm 'r0 a)))
		(decr vm 'pc))
		  
		  
	  (error "~S: fonction non reconnue." (car l))))))))

(defun get-register-list(vm l)
  (if(atom l)
      ()
    (if(not(registre?(car l)))
	(cons(car l)(get-register-list vm (cdr l)))
      (cons(get-register vm (car l))(get-register-list vm (cdr l))))))

;test si c'est une fonction de saut
(defun jump?(x)
  (or(eql x 'jump)(eql x 'jlo)(eql x 'jeq)(eql x 'jgr)(eql x 'jle)(eql x 'jge)(eql x 'jne)(eql x 'jsr)))

;resout les labels des jump anterieurs lors du chargement
(defun resoudre-label(vm table label ch)
  (loop for indice in (gethash label table)
	do
	(set-memory vm indice (list(car(get-memory vm indice))ch))))

;traite le cas des labels lors du chargement
(defun resolution-label(vm instruction table table-avant)
  (if(eql(gethash (cadr instruction)table)nil)
      (progn
	(setf(gethash (cadr instruction)table)(get-register vm 'CH))
	(resoudre-label vm table-avant (cadr instruction)(get-register vm 'CH)))
    (error "~S est deja defini comme label" (cadr instruction))))

;traite le cas des jump lors du chargement
(defun resolution-jump(vm instruction table table-avant)
  (if(eql(gethash (cadr instruction)table)nil)
      (progn
	(if(eql(gethash (cadr instruction)table-avant)nil)
	    (setf(gethash(cadr instruction)table-avant)`(,(get-register vm 'CH)))
	  (setf(gethash(cadr instruction)table-avant)(cons (get-register vm 'CH)(gethash(cadr instruction)table-avant))))
	(set-memory vm (get-register vm 'CH) instruction)
	(decr vm 'CH))
    (progn
      (set-memory vm (get-register vm 'CH)(list (car instruction)(gethash (cadr instruction)table)))
      (decr vm 'CH))))

;fonction de création de la vm
;vm: nom de la vm sur laquelle faire l'opération
;taille: la taille de la memoire allouer a la vm
(defun make-vm (vm taille)
  (progn
    (initialise-registre vm)
    (creation-memoire vm taille)
    vm))

;charge le code en memoire et resout les labels
(defun load-code(vm code)
  (setq table-locale (make-hash-table))
  (setq table-locale-avant (make-hash-table))
  (loop for bloc in code
	do
	(clrhash table-locale)
	(clrhash table-locale-avant)
	(loop for instruction in bloc
	      do
	      (if(eql(car instruction) 'LABEL)
		  (if(integerp(cadr instruction))
		      (resolution-label vm instruction table-locale table-locale-avant)
		    (resolution-label vm instruction table-globale table-globale-avant))
		(if(jump? (car instruction))
		    (if(integerp(cadr instruction))
			(resolution-jump vm instruction table-locale table-locale-avant)
		      (resolution-jump vm instruction table-globale table-globale-avant))
		  (progn
		    (set-memory vm (get-register vm 'CH) instruction)
		    (decr vm 'CH)))))))

;fonction d'execution de fonction indiquée par le label
(defun exe(vm label)
  (if(eql(gethash label table-globale)nil)
      (error "~S n'a pas été definie." label)
    (progn
      (jump vm (gethash label table-globale))
      (loop while(not(eql 'halt (lecture-ligne vm (get-memory vm (get-register vm 'pc))))))
      (print (get-register vm 'r0))
      (initialise-registre vm)
      "fin du programme")))
			  

;jeu de test
(defun L0()
  '(((label L0)(move 5 r1)(move 0 r2)(label 1)(comp r1 r2)(jeq 2)(print r2)(incr r2)(jump 1)(label 2)(rtn)(print "fin l0")(halt))))

(defun L1()
  '(((label L1)(move 5 r1)(move 0 r2)(label affiche)(comp r1 r2)(jeq fin)(print r2)(incr r2)(jump affiche)(label fin)(halt))))

(defun L2()
  '(((label L2)(push 1)(push 2)(push 3)(load 2 r0)(print r0)(store 14 1)(load 1 r1)(print r1)(jsr L0)(print "fin l2")(halt))))

(defun L3()
  '(((label L3)(setf a 2)(print a)(halt))))